home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d26 / cattest.arc / UTILITY.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-01  |  41KB  |  1,214 lines

  1. UNIT UTILITY;
  2. (*
  3.  August 7, 1990;    added erase after Pause, YesNo
  4.  August 14, 1990;   added Clear_all_blanks,
  5.                     added erasures at all exits to Read_Eqn
  6.  October 14, 1990;  added requirements for "good" input
  7.                     Read_Real_Masked
  8.                     1)cursor control
  9.                     2)insert/overtype switch
  10.                     3)legal character set
  11.                     4)legal function and editing keys
  12.                     5)default value on input entry
  13.                     6)default value on exit by ESC
  14.                     by adding Read_Masked_Number, and attempt using a
  15.                     '+0.yyyE+00' type mask to get input acceptable.
  16. October 26, 1990;    added changes to sound (NOISE)
  17. November 21, 1990;   added Read_Integer_Masked, cloned from above.
  18. November 28, 1990;   changed read_integer_masked to get sign position
  19.                     correct.
  20. November 30, 1990;   added Frame
  21.                     YesNo defaults to No if Carriage Return
  22. December 1, 1990     Txt := '' in read_integer_masked
  23.                     PF keys assigned
  24. January 4, 1991     Removed limits from read_real, changed name to
  25.                     read_float.
  26. January 8, 1991     Added Read_fixed, changed both to ignore decimal
  27.                     points.
  28. January 11, 1991    Cleaned up 'x' and 'y' from Read_fixed and read_float
  29.  
  30. April 3, 1991       Added Fileexists
  31.  
  32. *)
  33.  
  34. INTERFACE 
  35.  
  36. USES
  37. CRT;
  38.  
  39. TYPE 
  40.   Sounds = (Good,Bad,FinishedGood,FinishedBad,Acknowledge,Cont);
  41.   set_of_char = SET OF char;
  42.  
  43.   CONST 
  44.     OK_Message : STRING = 'O.K.';
  45.     Not_OK_Message : STRING = 'Not O.K.';
  46.     PF1 = #59;
  47.     PF2 = #60;
  48.     PF3 = #61;
  49.     PF4 = #62;
  50.     PF5 = #63;
  51.     PF6 = #64;
  52.     PF7 = #65;
  53.     PF8 = #66;
  54.     PF9 = #67;
  55.     PF10 = #68;
  56.  
  57. VAR 
  58.   Err,ErrPos : integer;     {Error response from Checking, and position}
  59.   Contents : STRING;                 { Contains a formula or some text }
  60.   Escape_struck,            {Global Variable which tells if ESC pressed}
  61.   PF : Boolean;   {Global Variable which tells if Function Keys pressed}
  62.   Ch,
  63.   variable : Char;
  64.   lc_var,uc_var : CHAR; { known case versions of variable }
  65.   question : STRING;                 {contains the question to be asked}
  66.  
  67. PROCEDURE NOISE(WhatSound:Sounds);
  68.  
  69. FUNCTION Read_Key: char;
  70.  
  71.  
  72. (*   page layout
  73.      X=1->80...
  74.      Y --------------------------
  75.      = |
  76.      1 |
  77.      | |
  78.      2 |
  79.      5 |
  80. *)
  81.  
  82. PROCEDURE Our_Write(x,
  83.                     y: {positions of cursor for first character}
  84.                     integer;
  85.                     s: {string to be written}
  86.                     STRING);
  87.  
  88. FUNCTION YesNo(x,
  89.                y: {positions of cursor for first character of prompt}
  90.                integer;
  91.                s: {prompt text}
  92.                STRING): boolean;
  93.  
  94. PROCEDURE Pause(x,
  95.                 y: {positions of cursor for first character of prompt}
  96.                 integer;
  97.                 s: {prompt text}
  98.                 STRING);
  99.  
  100. PROCEDURE CheckBrackets(Str: {formula containing string to be checked}
  101.                           STRING;
  102.                         VAR Err: {Code for error <>0 means yes}
  103.                           Integer;
  104.                         VAR Err_Message: {message string}
  105.                           STRING);
  106.  
  107. PROCEDURE Remove_double_blanks(VAR Str:STRING);
  108.  
  109. PROCEDURE Remove_all_blanks(VAR Str:STRING);
  110.  
  111. PROCEDURE Trim_fore_aft(VAR Str:STRING);
  112.  
  113. PROCEDURE PoseQuestion(line: {y position of line, x=1 assumed}
  114.                           INTEGER;
  115.                        question: {text of question, max length 255}
  116.                           STRING);
  117.  
  118. FUNCTION Read_Eqn(X,Y,L:integer;s:STRING): STRING; {original, obsolete}
  119.  
  120. FUNCTION Read_Number(X,Y,L:integer;s:STRING): STRING; {original, obsolete}
  121.  
  122. FUNCTION Read_Masked_Number(X,Y:integer;s,mask:STRING): STRING; {original, obsolete}
  123.  
  124. FUNCTION Read_Equation(X,
  125.                        Y, {positions of cursor for first character of prompt}
  126.                        L: {length of string allowed for this equation}
  127.                        integer;
  128.                        s:
  129.                        STRING;
  130.                        char_set:
  131.                        set_of_char): STRING;
  132.  
  133. PROCEDURE Read_Float_Masked
  134.                         (X,
  135.                          Y, {position of prompt}
  136.                          L: {number of places to right of decimal point}
  137.                            integer;
  138.                          Prompt:
  139.                            STRING;
  140.                          Print_Prompt : {show old value?}
  141.                            Boolean;
  142.                          VAR W : {resultant value/or original one}
  143.                          real);
  144.  
  145. PROCEDURE Read_Fixed_Masked
  146.                   (X,
  147.                    Y, {position of prompt}
  148.                    L_left,
  149.                    L_right {number of places to left and
  150.                                  right of decimal point}
  151.                    :integer;
  152.                    Prompt:STRING;
  153.                    Print_Prompt : Boolean; {show old value?}
  154.                    VAR W : real);
  155.  
  156. PROCEDURE Read_Integer_Masked
  157.                   (X,
  158.                    Y, {position of prompt}
  159.                    L {number of digits}
  160.                      :integer;
  161.                    Prompt
  162.                      :STRING;
  163.                    Print_Prompt {show old value?}
  164.                      : Boolean;
  165.                    VAR W {resultant value/or original one}
  166.                      :  integer);
  167.  
  168.  
  169. PROCEDURE Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
  170.  
  171. function FileExists(fn:string):boolean;
  172.  
  173. IMPLEMENTATION 
  174.  
  175. PROCEDURE NOISE(WhatSound:Sounds);
  176. {This procedure was invented by Peter Sawatzki, IN307@DHAEU11.bitnet
  177. address current as of Sept 26, 1990 }
  178.  
  179. VAR i,j : Byte;
  180.  
  181. BEGIN
  182.   CASE WhatSound OF
  183.     Cont :
  184.            BEGIN
  185.              Sound(500);
  186.              Delay(5);
  187.            END;
  188.     Good :
  189.            BEGIN
  190.              Sound(500);
  191.              Delay(30);
  192.            END;
  193.     Bad  :
  194.            BEGIN
  195.              Sound(100);
  196.              Delay(200);
  197.              Sound(200);
  198.              Delay(200);
  199.              Sound(300);
  200.              Delay(200);
  201.            END;
  202.     FinishedGood : FOR j := 1 TO 2 DO
  203.                             FOR i := 1 TO 5 DO
  204.                             BEGIN
  205.                             Sound(500+i*200);
  206.                          Delay(30);
  207.                        END;
  208.     FinishedBad  : FOR j := 1 TO 2 DO
  209.                             FOR i := 1 TO 5 DO
  210.                             BEGIN
  211.                             Sound(200-i*20);
  212.                          Delay(30);
  213.                        END;
  214.     Acknowledge   :
  215.                     BEGIN
  216.                       Sound(1000);
  217.                       Delay(15);
  218.                     END;
  219.   END;
  220.   NoSound;
  221. END;
  222.  
  223. FUNCTION Read_Key: char;
  224.  
  225. VAR 
  226.   temp_var : char;
  227.  
  228. BEGIN
  229.   Temp_var := ReadKey;
  230.   PF := False; {this was not a PF key}
  231.   IF Temp_var = #0
  232.     THEN PF := True; {Oh Yes it was, so read again}
  233.   IF PF
  234.     THEN Temp_var := ReadKey;
  235.   Escape_struck := False;
  236.   IF Temp_var = #27
  237.     THEN Escape_struck := True;
  238.   Read_key := Temp_var;
  239. END;
  240.  
  241. PROCEDURE Our_Write(X,Y:integer;s:STRING);
  242. BEGIN  {effect is to terminate line properly without carriage return}
  243.   GoToXY(X,Y);
  244.   Write(s);
  245.   ClrEol;
  246. END;
  247.  
  248.  
  249. FUNCTION YesNo(X,Y:integer;s:STRING): boolean;
  250. BEGIN
  251.   YesNo := False;
  252.   REPEAT
  253.     Our_Write(X,Y,s);
  254.     Ch := Read_Key;
  255.     Ch := UpCase(Ch);
  256.     UNTIL Ch IN ['Y','N',#13];
  257.     IF Ch = 'Y'
  258.       THEN YesNo := True
  259.       ELSE YesNo := False;
  260.     GoToXY(X,Y);
  261.     ClrEol;
  262. END;
  263.  
  264. PROCEDURE Pause(x,y:integer;s:STRING);
  265. BEGIN
  266.   Our_Write(x,y,s);
  267.   Ch := Read_Key;
  268.   GoToXY(x,y);
  269.   ClrEol;
  270. END;
  271.  
  272. PROCEDURE CheckBrackets(Str:STRING;
  273.                         VAR Err:Integer;  {Code for error <>0 means yes}
  274.                         VAR Err_Message:STRING); {message string}
  275.  
  276. VAR 
  277.   i,k : integer;
  278. BEGIN
  279.   Err := 0;
  280.   Err_Message := OK_Message;
  281.   i := 0;
  282.   FOR k := 1 TO Length(Str) DO
  283.            BEGIN
  284.            IF Str[k] = '('
  285.            THEN inc(i)
  286.         ELSE IF Str[k] = ')'
  287.                THEN dec(i);
  288.     END;
  289.   IF i <> 0
  290.     THEN
  291.       BEGIN
  292.         Err := 1;
  293.         Err_Message := 'Brackets do not match.';
  294.       END;
  295. END;
  296.  
  297. PROCEDURE Remove_double_blanks(VAR Str:STRING);
  298.  
  299. VAR 
  300.   k : integer;
  301. BEGIN
  302.   k := POS('  ',Str);
  303.   WHILE k > 0  DO
  304.     BEGIN
  305.       delete(Str,k,1);
  306.       k := POS('  ',Str);
  307.     END;
  308. END;
  309.  
  310. PROCEDURE Remove_all_blanks(VAR Str:STRING);
  311.  
  312. VAR 
  313.   k_blank : integer;
  314. BEGIN
  315.   k_blank := POS(' ',Str);
  316.   WHILE k_blank <> 0 DO
  317.     BEGIN
  318.       Delete(Str,k_blank,1);
  319.       k_blank := POS(' ',Str);
  320.     END;
  321. END;
  322.  
  323. PROCEDURE Trim_fore_aft(VAR Str:STRING);
  324. BEGIN
  325.   WHILE Str[1] = ' ' DO
  326.                  delete(Str,1,1);
  327.   WHILE Str[Length(Str)] = ' ' DO
  328.                            delete(Str,Length(Str),1);
  329. END;
  330.  
  331. PROCEDURE PoseQuestion(line:INTEGER;question:STRING);
  332.  
  333. VAR 
  334.   k,kk,ypos  : Integer;
  335. BEGIN {purpose is to write a question on the screen without splitting
  336.                                                          words.}
  337.  
  338.   Remove_Double_blanks(question);
  339.   GoToXY(1,line);
  340.   k := 79;
  341.   ypos := line;
  342.   WHILE Length(question) > 79 DO
  343.     BEGIN
  344.       WHILE question[k]<>' ' DO
  345.         dec(k); {find last blank less than 80
  346.                                      characters in from r.h.s}
  347.       IF k <2
  348.         THEN
  349.           BEGIN
  350.             Pause(1,25,'Your text can not be split into 80 char units.');
  351.             halt;
  352.           END;
  353.       FOR kk := 1 TO k DO
  354.                 Write(question[kk]); {write those characters}
  355.       ClrEol;                          {clean up the rest of the line.}
  356.       inc(ypos); {goto next line}
  357.       GoToXY(1,ypos);
  358.       IF k > 1
  359.         THEN Delete(question,1,k); {delete part written out already}
  360.     END;
  361.   Write(question);
  362.   ClrEol; {write the last section and clean up.}
  363. END; {PoseQuestion}
  364.  
  365. FUNCTION Read_Eqn(X,Y,L:integer;s:STRING): STRING;
  366.  
  367. VAR 
  368.   Ichar : char;
  369.   done  : Boolean;
  370.   s1 : STRING;
  371.  
  372.   CONST 
  373.     CR = #13; {Carriage Return}
  374.     BS = #8;  {Back Space}
  375.  
  376. BEGIN
  377.   uc_var := UpCase(variable);
  378.   IF variable = uc_var
  379.     THEN
  380.       lc_var := CHR(ORD(variable)+$20);
  381.   s1 := '';
  382.   done := False;
  383.   Our_Write(X,Y,s);
  384.   IChar := #0; {set to not carriage return }
  385.   WHILE (Ichar <> CR) AND (Length(s1)<= L)
  386.                                          DO {do not continue past the Carriage Return}
  387.                                          BEGIN
  388.                                          REPEAT
  389.                                            IChar := Read_Key; {get a character }
  390.                                            IF Escape_Struck
  391.                                              THEN
  392.                                                BEGIN
  393.                                                  s1 := '';
  394.                                                  GoToXY(X,Y);
  395.                                                  ClrEol;
  396.                                                  exit;
  397.                                                END;
  398.                                            UNTIL Ichar IN ['0'..'9','.',
  399.                                            { legal numerics }
  400.                                            CR,
  401.                                            { line terminator and end }
  402.                                            BS,
  403.                                            { back space, erase last char }
  404.                                            variable,
  405.                                            { the global char used as variable }
  406.                                            lc_var,
  407.                                            uc_var,
  408.                                            {upper / lower case versions of var }
  409.                                            '+','-','/','*',          { allowed operators }
  410.                                            '^',                      { power symbol }
  411.                                            '(',')',                  { grouping symbols }
  412.                                            '?'];
  413.                                            { UNIVERSAL help symbol }
  414.                                            IF Ichar = '?'
  415.                                              THEN
  416.                                                BEGIN
  417.                                                  Read_Eqn := Ichar;
  418.                                                  { ignore partial input and }
  419.                                                  GoToXY(X,Y);
  420.                                                  ClrEol;
  421.                                                  exit;
  422.                                                  {     leave this function }
  423.                                                END
  424.                                              ELSE
  425.                                                IF Ichar = CR
  426.                                                  THEN done := True
  427.                                                         { do not append, signal finished }
  428.                                                  ELSE
  429.                                                    IF (Ichar = BS) AND (Length(s1) > 0 )
  430.                                                       { deleteable? }
  431.                                                      THEN delete(s1,length(s1),1)
  432.                                                      ELSE s1 := s1 + Ichar;
  433.                                            Our_Write(X,Y,s1);
  434.                                          END;
  435.   Read_Eqn := s1;
  436.   GoToXY(X,Y);
  437.   ClrEol;
  438. END;
  439.  
  440. FUNCTION Read_Number(X,Y,L:integer;s:STRING): STRING;
  441.  
  442. VAR 
  443.   Ichar : char;
  444.   done  : Boolean;
  445.   s1 : STRING;
  446.  
  447.   CONST 
  448.     CR = #13; {Carriage Return}
  449.     BS = #8;  {Back Space}
  450.  
  451. BEGIN
  452.   uc_var := UpCase(variable);
  453.   IF variable = uc_var
  454.     THEN
  455.       lc_var := CHR(ORD(variable)+$20);
  456.   s1 := '';
  457.   done := False;
  458.   Our_Write(X,Y,s);
  459.   IChar := #0; {set to not carriage return }
  460.   WHILE (Ichar <> CR) AND (Length(s1)<= L)
  461.                                          DO {do not continue past the Carriage Return}
  462.                                          BEGIN
  463.                                          REPEAT
  464.                                            IChar := Read_Key; {get a character }
  465.                                            IF Escape_Struck
  466.                                              THEN
  467.                                                BEGIN
  468.                                                  s1 := '';
  469.                                                  GoToXY(X,Y);
  470.                                                  ClrEol;
  471.                                                  exit;
  472.                                                END;
  473.                                            UNTIL Ichar IN ['0'..'9','.',
  474.                                            { legal numerics }
  475.                                            CR,
  476.                                            { line terminator and end }
  477.                                            BS,
  478.                                            { back space, erase last char }
  479.                                            variable,
  480.                                            { the global char used as variable }
  481.                                            lc_var,
  482.                                            uc_var,
  483.                                            {upper / lower case versions of var }
  484.                                            '+','-','/','*',          { allowed operators }
  485.                                            '^',                      { power symbol }
  486.                                            '(',')',                  { grouping symbols }
  487.                                            '?'];
  488.                                            { UNIVERSAL help symbol }
  489.                                            IF Ichar = '?'
  490.                                              THEN
  491.                                                BEGIN
  492.  
  493.                                                  GoToXY(X,Y);
  494.                                                  ClrEol;
  495.                                                  exit;
  496.                                                  {     leave this function }
  497.                                                END
  498.                                              ELSE
  499.                                                IF Ichar = CR
  500.                                                  THEN done := True
  501.                                                         { do not append, signal finished }
  502.                                                  ELSE
  503.                                                    IF (Ichar = BS) AND (Length(s1) > 0 )
  504.                                                       { deleteable? }
  505.                                                      THEN delete(s1,length(s1),1)
  506.                                                      ELSE s1 := s1 + Ichar;
  507.                                            Our_Write(X,Y,s1);
  508.                                          END;
  509.   Read_Number := s1;
  510.   GoToXY(X,Y);
  511.   ClrEol;
  512. END;
  513.  
  514. FUNCTION Read_Masked_Number(X,Y:integer;s,mask:STRING): STRING;
  515.  
  516. VAR 
  517.   Ichar : char;
  518.   done  : Boolean;
  519.   s1 : STRING;
  520.   L : Integer;
  521.  
  522.   CONST 
  523.     CR = #13; {Carriage Return}
  524.     BS = #8;  {Back Space}
  525.  
  526. BEGIN
  527.   uc_var := UpCase(variable);
  528.   IF variable = uc_var
  529.     THEN
  530.       lc_var := CHR(ORD(variable)+$20);
  531.   s1 := '';
  532.   done := False;
  533.   Our_Write(X,Y,s);
  534.   L := Length(mask);
  535.   IChar := #0; {set to not carriage return }
  536.   WHILE (Ichar <> CR) AND (Length(s1)   <= L )
  537.                                             DO {do not continue past the Carriage Return}
  538.                                             BEGIN
  539.                                             REPEAT
  540.                                               IChar := Read_Key; {get a character }
  541.                                               IF Escape_Struck
  542.                                                 THEN
  543.                                                   BEGIN
  544.                                                     s1 := '';
  545.                                                     GoToXY(X,Y);
  546.                                                     ClrEol;
  547.                                                     exit;
  548.                                                   END;
  549.                                               UNTIL Ichar IN ['0'..'9','.',
  550.                                            { legal numerics }
  551.                                               CR,
  552.                                            { line terminator and end }
  553.                                               BS,
  554.                                            { back space, erase last char }
  555.                                               '^'];                     { power symbol }
  556.  
  557.                                               IF Ichar = CR
  558.                                                 THEN done := True
  559.                                                         { do not append, signal finished }
  560.                                                 ELSE
  561.                                                   IF (Ichar = BS) AND (Length(s1) > 0 )
  562.                                                   { deleteable? }
  563.                                                     THEN delete(s1,length(s1),1)
  564.                                                     ELSE s1 := s1 + Ichar;
  565.                                               Our_Write(X,Y,mask);
  566.                                               Our_Write(X,Y+L+1,s1);
  567.                                             END;
  568.   Read_Masked_Number := s1;
  569.   GoToXY(X,Y);
  570.   ClrEol;
  571. END;
  572.  
  573. FUNCTION Read_Equation(X,Y,L:integer;s:STRING;char_set:set_of_char): STRING;
  574.  
  575. VAR 
  576.   Ichar : char;
  577.   done  : Boolean;
  578.   s1 : STRING;
  579.   operating_char_set : set_of_char;
  580.  
  581.   CONST 
  582.     CR = #13; {Carriage Return}
  583.     BS = #8;  {Back Space}
  584.  
  585. BEGIN
  586.   operating_char_set := ['0'..'9','.', { legal numerics }
  587.                         CR,                       { line terminator and end }
  588.                         BS,                       { back space, erase last char }
  589.                         variable,                 { the global char used as variable }
  590.                         lc_var,
  591.                         uc_var,                   {upper / lower case versions of var }
  592.                         '+','-','/','*',          { allowed operators }
  593.                         '^',                      { power symbol }
  594.                         '(',')',                  { grouping symbols }
  595.                         '?'] + char_set;
  596.   uc_var := UpCase(variable);
  597.   IF variable = uc_var
  598.     THEN
  599.       lc_var := CHR(ORD(variable)+$20);
  600.   s1 := '';
  601.   done := False;
  602.   Our_Write(X,Y,s);
  603.   IChar := #0; {set to not carriage return }
  604.   WHILE (Ichar <> CR) AND (Length(s1) <= L)
  605.                                           DO {do not continue past the Carriage Return}
  606.                                           BEGIN
  607.                                           REPEAT
  608.                                             IChar := Read_Key; {get a character }
  609.                                             IF Escape_Struck
  610.                                               THEN
  611.                                                 BEGIN
  612.                                                   s1 := '';
  613.                                                   GoToXY(X,Y);
  614.                                                   ClrEol;
  615.                                                   exit;
  616.                                                 END;
  617.                                             UNTIL Ichar IN operating_char_set;
  618.  
  619.                                             IF Ichar = '?'
  620.                                               THEN
  621.                                                 BEGIN
  622.                                                   Read_Equation := Ichar;
  623.                                                  { ignore partial input and }
  624.                                                   GoToXY(X,Y);
  625.                                                   ClrEol;
  626.                                                   exit;
  627.                                                  {     leave this function }
  628.                                                 END
  629.                                               ELSE
  630.                                                 IF Ichar = CR
  631.                                                   THEN done := True
  632.                                                         { do not append, signal finished }
  633.                                                   ELSE
  634.                                                     IF (Ichar = BS) AND (Length(s1) > 0 )
  635.                                                       { deleteable? }
  636.                                                       THEN delete(s1,length(s1),1)
  637.                                                       ELSE s1 := s1 + Ichar;
  638.                                             Our_Write(X,Y,s1);
  639.                                           END;
  640.   Read_Equation := s1;
  641.   GoToXY(X,Y);
  642.   ClrEol;
  643. END;
  644.  
  645. { From: "Chunqing N. Cheng" <cncst3@unix.cis.pitt.edu>
  646. (edited enclosure message follows)
  647. The TechnoJock Toolkit is so lousy on real numbers, it
  648. cannot show them correctly.  It just shows very small number as all
  649. bunches of zero's.
  650.  
  651. For me, an engineer, a program should accept a real number just like
  652. a computer without keyboard.  So, I started to modify the code.
  653. The following is the modified part, with the capability to
  654.  
  655. 1.  display a real number smartly.  I mean that if it cannot fit
  656.   in normal way, it goes to scientific format automatically.
  657.   So, you do not need separately procedure for this.
  658.  
  659. 2.  Accept scientific format.
  660.  
  661. 3.  retain others in original way, (hopefully).
  662.  
  663. }
  664.  
  665. FUNCTION inttoStr(i:longint): STRING;
  666.  
  667. VAR 
  668.   s: STRING[11];
  669. BEGIN
  670.   str(i,s);
  671.   inttostr := s;
  672. END;
  673.  
  674. FUNCTION Real_to_str(Number:real;Decimals:byte): STRING;
  675.  
  676. VAR Temp : STRING;
  677.   i: byte;
  678.   sign : STRING[1];
  679.   power: word;
  680.  
  681. FUNCTION Strip(left_right,character : char;VAR s:STRING): STRING;
  682. BEGIN
  683.   IF UpCase(left_right) = 'R'
  684.     THEN
  685.       WHILE s[length(s)] = character DO
  686.                            s := copy (s,1,length(s)-1)
  687.       ELSE IF UpCase(left_right) = 'L'
  688.              THEN
  689.                WHILE s[1] = character DO
  690.                             s := copy(s,2,length(s));
  691.   strip := s;
  692.   END;
  693.  
  694.  
  695. CONST 
  696.   Floating : byte = 3;
  697.  
  698. VAR 
  699.   Width : Integer;
  700.   t1 : real;
  701. BEGIN
  702.   Real_to_Str := '';
  703.   IF abs(number)>0.
  704.     THEN t1 := ln(ABS(number))/2.303
  705.     ELSE exit;
  706.   Width := abs(TRUNC(t1));
  707.   IF number > -1.E+11
  708.     THEN {will fit in eleven decimal digits when
  709.                             made into a string, what about Planck's
  710.                                         constant?}
  711.       Str(Number:Width+Decimals:11
  712.                                 {max for TURBO},
  713.                                 Temp);
  714.   REPEAT
  715.        IF copy(Temp,1,1) = ' '
  716.          THEN delete(Temp,1,1);
  717.     UNTIL copy(temp,1,1) <> ' ';
  718.     Real_to_Str := Temp;
  719.     IF Decimals+7 < Width
  720.       THEN
  721.         BEGIN
  722.           Temp := Strip('R','0',Temp);
  723.           IF Temp[Length(temp)] = '.'
  724.             THEN
  725.               Delete(temp,Length(temp),1);
  726.           IF ((Temp='0') AND (Number<>0)) OR (abs(number)>1.0E12)
  727.              OR ((Temp='-0') AND (Number<>0))
  728.             THEN
  729.               BEGIN
  730.                 sign := '';
  731.                 IF number<0
  732.                   THEN sign := '-';
  733.                 number := abs(number);
  734.                 power := 0;
  735.                 IF number<1
  736.                   THEN
  737.                     BEGIN
  738.                     REPEAT
  739.                       power := power+1;
  740.                       number := number*10;
  741.                       UNTIL number >= 1;
  742.                       IF sizeof(number)=6
  743.                         THEN Str(Number:20:12,Temp)
  744.                                ELSE Str(Number:20:8,Temp);
  745.                     REPEAT
  746.                       IF copy(Temp,1,1) = ' '
  747.                         THEN delete(Temp,1,1);
  748.                       UNTIL copy(temp,1,1) <> ' ';
  749.                       Temp := Sign+Strip('R','0',Temp)+'E-'+inttoStr(power);
  750.                     END
  751.                   ELSE
  752.                     BEGIN
  753.                     REPEAT
  754.                       power := power+1;
  755.                       number := number/10;
  756.                       UNTIL number<10;
  757.                       IF sizeof(number)=6
  758.                         THEN Str(Number:20:12,Temp)
  759.                         ELSE Str(Number:20:8,Temp);
  760.                     REPEAT
  761.                       IF copy(Temp,1,1) = ' '
  762.                         THEN delete(Temp,1,1);
  763.                       UNTIL copy(temp,1,1) <> ' ';
  764.                       Temp := Sign+Strip('R','0',Temp)+'E'+inttoStr(power);
  765.                     END;
  766.               END;
  767.           Real_to_Str := Temp;
  768.         END;
  769. END;
  770.  
  771. {================================================}
  772.  
  773. PROCEDURE Read_Line(X, {x-position of cursor at outset}
  774.                     Y, {y-position of cursor at outset}
  775.                     L_left,
  776.                     L_right  {number of places to right of decimal point}
  777.                     :integer;
  778.                     VAR Text {resultant character representation
  779.                              of the number                     }
  780.                     :STRING);
  781.  
  782. CONST 
  783.   CursorRight = #77;
  784.   CursorLeft = #75;
  785.   Home_Key = #71;
  786.   End_Key = #79;
  787.   Ins_Key = #82;
  788.   Del_Key = #83;
  789.   BackSpace = #15;
  790.   Esc_Key = #27;
  791.   Enter_Key = #13;
  792.  
  793. VAR 
  794.   k_digits,Where_sign,
  795.   Cursor_X,Cursor_Y,CursorPos : byte;
  796.   Insert,InsertMode,FirstCharPress,AllDone: Boolean;
  797.   Ch : Char;
  798.   TempText : STRING;
  799.  
  800. PROCEDURE WriteString;
  801. BEGIN
  802.   GoToXY(Cursor_X,Cursor_Y);
  803.   Write(TempText);
  804.   ClrEol;
  805.   GoToXY(Cursor_X+CursorPos-1,Cursor_Y);
  806. END;
  807.  
  808. PROCEDURE InsertChar;
  809.  
  810. VAR 
  811.   TempCh : Char;
  812. BEGIN
  813.   TempText[CursorPos] := Ch;
  814.   IF CursorPos < Length(TempText)
  815.     THEN
  816.       BEGIN
  817.         CursorPos := succ(CursorPos);
  818.         TempCh := TempText[CursorPos];
  819.         IF (TempCh = '.') OR
  820.            (TempCh = '+' ) OR
  821.            (TempCh = '-' ) OR
  822.            (TempCh = 'E' )
  823.           THEN CursorPos := succ(CursorPos);
  824.       END;
  825. END;
  826.  
  827. BEGIN                  {main Procedure Read_Line}
  828.   FirstCharPress := false;
  829.   Cursor_X := WhereX;
  830.   Cursor_Y := WhereY;{mark end of prompt}
  831.   CursorPos := 2;
  832.   Insert := False;
  833.   AllDone := False;
  834.   IF L_left = 0
  835.     THEN
  836.       BEGIN
  837.         IF L_right > 0
  838.           THEN
  839.             BEGIN
  840.               TempText := '+0.y';
  841.               FOR k_digits := 2 TO L_right DO
  842.                               TempText := TempText + 'y';
  843.               TempText := TempText+'E+00';
  844.               Where_sign := Length(TempText)-2;
  845.             END
  846.           ELSE {trick for doing integer reads}
  847.             BEGIN
  848.               TempText := ' 0';
  849.               FOR k_digits := 2 TO abs(L_right) DO
  850.                               TempText := TempText+'0';
  851.               L_right := abs(L_right);
  852.               Where_sign := 0;
  853.             END;
  854.       END
  855.     ELSE
  856.       BEGIN {fixed read}
  857.         TempText := ' ';
  858.         FOR k_digits := 1 TO L_left DO
  859.                         TempText := TempText + 'x';
  860.         TempText := TempText + '.';
  861.         FOR k_digits := 2 TO L_right DO
  862.                         TempText := TempText + 'y';
  863.       END;
  864.   WriteString;
  865.  
  866.   FirstCharPress := true;
  867.   REPEAT
  868.        Ch := ReadKey;
  869.        IF Ch = #0 {this was a function key pressed}
  870.          THEN Ch := ReadKey; {cursor pad}
  871.        Ch := upcase(Ch);
  872.        IF Ch IN [Esc_Key,Enter_Key]
  873.          THEN
  874.            BEGIN
  875.              AllDone := True;
  876.              IF CH = Esc_Key
  877.                THEN
  878.                  BEGIN
  879.                    Escape_Struck := True;
  880.                    exit;
  881.                  END
  882.                ELSE
  883.                  IF Ch <> Esc_Key
  884.                    THEN
  885.                      BEGIN
  886.                        FOR CursorPos := 1 TO Length(TempText) DO
  887.                                         IF  (TempText[CursorPos] =
  888.                                         'y') OR
  889.                                           (TempText[CursorPos] =
  890.                                         'x')
  891.                                         THEN TempText[CursorPos] := '0';{clean
  892.                                                              up mask}
  893.  
  894.                        Text := TempText;
  895.                      END;
  896.            END {of carriage return or escape}
  897.          ELSE
  898.            CASE Ch OF
  899.              CursorRight   :
  900.                              BEGIN
  901.                                 IF CursorPos < length(TempText)
  902.                                   THEN
  903.                                     BEGIN
  904.                                       CursorPos := Succ(CursorPos);
  905.                                       IF (TempText[CursorPos] = '.') OR
  906.                                          (TempText[CursorPos] = 'E')
  907.                                         THEN
  908.                                           CursorPos := Succ(CursorPos);
  909.                                       GoToXY(Cursor_X + CursorPos,Cursor_Y);
  910.                                     END
  911.                                   ELSE
  912.                                     Noise(Bad);
  913.                              END;
  914.              CursorLeft    :
  915.                              BEGIN
  916.                                 IF CursorPos > 1
  917.                                   THEN
  918.                                     BEGIN
  919.                                       CursorPos := Pred(CursorPos);
  920.                                       IF (TempText[CursorPos] = '.') OR
  921.                                          (TempText[CursorPos] = 'E')
  922.                                         THEN
  923.                                           CursorPos := Pred(CursorPos);
  924.                                       GoToXY(Cursor_X + CursorPos,Cursor_Y);
  925.                                     END
  926.                                   ELSE
  927.                                     Noise(Bad);
  928.                              END;
  929.              Home_Key       :
  930.                               BEGIN
  931.                                  CursorPos := 1;
  932.                                  GoToXY(Cursor_X+CursorPos,Cursor_Y);
  933.                               END;
  934.              End_Key        :
  935.                               BEGIN
  936.                                  CursorPos := Length(TempText);
  937.                                  GoToXY(Cursor_X + CursorPos,Cursor_Y);
  938.                               END;
  939.  
  940.              BackSpace    :       {Char_Backspace, treat as cursor}
  941.                               BEGIN
  942.                                 IF CursorPos > 1
  943.                                   THEN
  944.                                     BEGIN
  945.                                       CursorPos := Pred(CursorPos);
  946.                                       IF (TempText[CursorPos] = '.') OR
  947.                                          (TempText[CursorPos] = 'E')
  948.                                         THEN
  949.                                           CursorPos := Pred(CursorPos);
  950.                                       GoToXY(Cursor_X + CursorPos,Cursor_Y);
  951.                                     END
  952.                                   ELSE
  953.                                     Noise(Bad);
  954.                              END;
  955.              Esc_Key        :   Alldone := true;
  956.              Enter_Key      :
  957.                               BEGIN
  958.                                  Alldone := true;
  959.                                  IF Ch <> Esc_Key
  960.                                    THEN
  961.                                      BEGIN
  962.                                        FOR CursorPos := 1 TO Length(TempText) DO
  963.                                                         IF  (TempText[CursorPos] =
  964.                                                         'y') OR
  965.                                                         (TempText[CursorPos] =
  966.                                                         'x')
  967.                                                         THEN TempText[CursorPos] := '0';
  968.                                        {clean
  969.                                                              up mask}
  970.                                         END;
  971.                                  Text := TempText;
  972.                               END;
  973.              #43          :
  974.                             BEGIN {plus sign}
  975.                               IF (CursorPos = 1) OR (CursorPos =Where_sign )
  976.                                     THEN
  977.                                       InsertChar;
  978.                             END;
  979.              #45          :
  980.                             BEGIN {minus sign}
  981.                               IF (CursorPos = 1) OR (CursorPos =Where_sign )
  982.                                 THEN
  983.                                   InsertChar;
  984.                             END;
  985.  
  986.              #48..#57,' ' :
  987.                             BEGIN {digits, 0 to 9}
  988.                               IF Ch = ' '
  989.                                 THEN Ch := '0';
  990.                                 IF (CursorPos <> 1) AND
  991.                                    (CursorPos <= Length(TempText)) AND
  992.                                    (CursorPos <> Where_sign ) AND
  993.                                    (TempText[CursorPos] <> '.') AND
  994.                                    (TempText[CursorPos] <> 'E')
  995.                                   THEN
  996.                                     InsertChar;
  997.                               END;
  998.              '.'            : ;
  999.            ELSE Noise(Bad);
  1000.     END; {case}
  1001.     FirstCharPress := false;
  1002.     WriteString;
  1003.  
  1004.     UNTIL Alldone;
  1005.  
  1006. END;  {Proc Read_Line}
  1007.  
  1008. PROCEDURE Read_Float_Masked
  1009.                   (X,
  1010.                    Y, {position of prompt}
  1011.                    L {number of places to right of decimal point}
  1012.                    :integer;
  1013.                    Prompt:STRING;
  1014.                    Print_Prompt : Boolean; {show old value?}
  1015.                    VAR W : real);
  1016.  
  1017. VAR 
  1018.   Temp : Real;
  1019.   Txt : STRING;
  1020.   Valid : boolean;
  1021.   Code : integer;
  1022.   YT : byte;
  1023.   ChR : char;
  1024. BEGIN
  1025.   Txt := '';
  1026.   IF W <> 0.0
  1027.     THEN Txt := Real_To_Str(W,L);
  1028.  
  1029.   IF Print_Prompt AND (Txt <> '')
  1030.     THEN
  1031.           Prompt := Prompt + '(old = '+Txt+'):';
  1032.   Temp := W;
  1033.   Valid := false;
  1034.   REPEAT
  1035.     GoToXY(X,Y);
  1036.     ClrEol;
  1037.     GoToXY(X,Y);
  1038.     Write(Prompt);
  1039.     Read_Line(X,Y,0,L,Txt);
  1040.     IF Escape_Struck {the person hit the escape key}
  1041.       THEN exit
  1042.       ELSE
  1043.         BEGIN
  1044.     {$R-}
  1045.           val(Txt,Temp,code);
  1046.     {$R+}
  1047.           IF code <> 0
  1048.             THEN
  1049.               BEGIN
  1050.                 noise(bad);
  1051.                 delay(1000);
  1052.               END
  1053.             ELSE
  1054.               BEGIN
  1055.                 W := Temp; {accept as OK number}
  1056.                 Valid := true;
  1057.               END;
  1058.         END;
  1059.     UNTIL valid ;
  1060. END;
  1061.  
  1062. PROCEDURE Read_Fixed_Masked
  1063.                   (X,
  1064.                    Y, {position of prompt}
  1065.                    L_left,
  1066.                    L_right {number of places to left and
  1067.                                  right of decimal point}
  1068.                    :integer;
  1069.                    Prompt:STRING;
  1070.                    Print_Prompt : Boolean; {show old value?}
  1071.                    VAR W : real);
  1072.  
  1073. VAR 
  1074.   Temp : Real;
  1075.   Txt : STRING;
  1076.   Valid : boolean;
  1077.   Code : integer;
  1078.   YT : byte;
  1079.   ChR : char;
  1080. BEGIN
  1081.   Txt := '';
  1082.   IF W <> 0
  1083.     THEN Txt := Real_To_Str(W,L_left+L_right);
  1084.  
  1085.   IF Print_Prompt AND (Txt <> '')
  1086.     THEN
  1087.           Prompt := Prompt + '(old = '+Txt+'):';
  1088.   Temp := W;
  1089.   Valid := false;
  1090.   REPEAT
  1091.     GoToXY(X,Y);
  1092.     ClrEol;
  1093.     GoToXY(X,Y);
  1094.     Write(Prompt);
  1095.     Read_Line(X,Y,L_left,L_right,Txt);
  1096.     IF Escape_Struck {the person hit the escape key}
  1097.       THEN exit
  1098.       ELSE
  1099.         BEGIN
  1100.     {$R-}
  1101.           val(Txt,Temp,code);
  1102.     {$R+}
  1103.           IF code <> 0
  1104.             THEN
  1105.               BEGIN
  1106.                 noise(bad);
  1107.                 delay(1000);
  1108.               END
  1109.             ELSE
  1110.               BEGIN
  1111.                 W := Temp; {accept as OK number}
  1112.                 Valid := true;
  1113.               END;
  1114.         END;
  1115.     UNTIL valid ;
  1116. END;
  1117.  
  1118. PROCEDURE Read_Integer_Masked
  1119.                   (X,
  1120.                    Y, {position of prompt}
  1121.                    L {number of digits}
  1122.                    :integer;
  1123.                    Prompt:STRING;
  1124.                    Print_Prompt : Boolean; {show old value?}
  1125.                    VAR W : integer);
  1126.  
  1127. VAR 
  1128.   Temp : Integer;
  1129.   Txt : STRING;
  1130.   Valid : boolean;
  1131.   Code : integer;
  1132.   YT : integer;
  1133.   ChR : char;
  1134. BEGIN
  1135.   Txt := '';
  1136.   IF W <> 0
  1137.     THEN Txt := IntToStr(W);
  1138.  
  1139.   IF Print_Prompt AND (Txt <> '')
  1140.     THEN
  1141.           Prompt := Prompt + '(old = '+Txt+'):';
  1142.   Temp := W;
  1143.   Valid := false;
  1144.   REPEAT
  1145.     GoToXY(X,Y);
  1146.     ClrEol;
  1147.     GoToXY(X,Y);
  1148.     Write(Prompt);
  1149.     YT := -L;
  1150.     Escape_Struck := False;
  1151.     Read_Line(X,Y,0,YT,Txt);{use this trick to force integer}
  1152.     IF Escape_Struck {the person hit the escape key}
  1153.       THEN exit
  1154.       ELSE
  1155.         BEGIN
  1156.     {$R-}
  1157.           val(Txt,Temp,code);
  1158.     {$R+}
  1159.           IF code <> 0
  1160.             THEN
  1161.               BEGIN
  1162.                 noise(bad);
  1163.                 delay(1000);
  1164.               END
  1165.             ELSE
  1166.               BEGIN
  1167.                 W := Temp; {accept as OK number}
  1168.  
  1169.                 Valid := true;
  1170.               END;
  1171.         END;
  1172.     UNTIL valid ;
  1173. END;
  1174.  
  1175. PROCEDURE Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
  1176.  
  1177. VAR  I : Integer;
  1178.  
  1179. BEGIN {Frame}
  1180.   GotoXY(UpperLeftX, UpperLeftY);
  1181.   Write(chr(218));
  1182.   FOR I := (UpperLeftX + 1) TO (LowerRightX - 1) DO
  1183.            BEGIN
  1184.            Write(chr(196));
  1185.     END;
  1186.   Write(chr(191));
  1187.   FOR I := (UpperLeftY + 1) TO (LowerRightY - 1) DO
  1188.            BEGIN
  1189.            GotoXY(UpperLeftX , I);
  1190.       Write(chr(179));
  1191.       GotoXY(LowerRightX, I);
  1192.       Write(chr(179));
  1193.     END;
  1194.   GotoXY(UpperLeftX, LowerRightY);
  1195.   Write(chr(192));
  1196.   FOR I := (UpperLeftX + 1) TO (LowerRightX - 1) DO
  1197.            BEGIN
  1198.            Write(chr(196));
  1199.     END;
  1200.   Write(chr(217));
  1201. END; {Frame}
  1202. function FileExists(fn:string):boolean;
  1203. var
  1204.   f : file;
  1205. begin
  1206. {$I-}
  1207.   assign(f,fn);
  1208.   reset(f);
  1209.   close(f);
  1210.   {$I+}
  1211.   FileExists := (IOResult = 0) and (fn<>'');
  1212. end;
  1213. END.
  1214.